home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / PICKDATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  31.7 KB  |  1,148 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit PickDate;
  13.  
  14. {$I RX.INC}
  15. {$S-}
  16.  
  17. interface
  18.  
  19. uses Windows, Classes, Variants, Controls, SysUtils, Graphics, DateUtil;
  20.  
  21. { Calendar dialog }
  22.  
  23. function SelectDate(var Date: TDateTime; const DlgCaption: TCaption;
  24.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  25.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  26. function SelectDateStr(var StrDate: string; const DlgCaption: TCaption;
  27.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  28.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  29. function PopupDate(var Date: TDateTime; Edit: TWinControl): Boolean;
  30.  
  31. { Popup calendar }
  32.  
  33. function CreatePopupCalendar(AOwner: TComponent
  34.   {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
  35. procedure SetupPopupCalendar(PopupCalendar: TWinControl;
  36.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  37.   AWeekendColor: TColor; BtnHints: TStrings; FourDigitYear: Boolean);
  38.  
  39. const
  40.   PopupCalendarSize: TPoint = (X: 187; Y: 124);
  41.  
  42. implementation
  43.  
  44. uses Messages, Consts, Forms, Buttons, StdCtrls, Grids, ExtCtrls, RXCtrls,
  45.   RXCConst, ToolEdit, VCLUtils, MaxMin, rxStrUtils;
  46.  
  47. {$IFDEF WIN32}
  48.  {$R *.R32}
  49. {$ELSE}
  50.  {$R *.R16}
  51. {$ENDIF}
  52.  
  53. const
  54.   SBtnGlyphs: array[0..3] of PChar = ('PREV2', 'PREV1', 'NEXT1', 'NEXT2');
  55.  
  56. procedure FontSetDefault(AFont: TFont);
  57. {$IFDEF WIN32}
  58. var
  59.   NonClientMetrics: TNonClientMetrics;
  60. {$ENDIF}
  61. begin
  62. {$IFDEF WIN32}
  63.   NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  64.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  65.     AFont.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont)
  66.   else
  67. {$ENDIF}
  68.   with AFont do begin
  69.     Color := clWindowText;
  70.     Name := 'MS Sans Serif';
  71.     Size := 8;
  72.     Style := [];
  73.   end;
  74. end;
  75.  
  76. { TRxTimerSpeedButton }
  77.  
  78. type
  79.   TRxTimerSpeedButton = class(TRxSpeedButton)
  80.   public
  81.     constructor Create(AOwner: TComponent); override;
  82.   published
  83.     property AllowTimer default True;
  84.     property Style default bsWin31;
  85.   end;
  86.  
  87. constructor TRxTimerSpeedButton.Create(AOwner: TComponent);
  88. begin
  89.   inherited Create(AOwner);
  90.   Style := bsWin31;
  91.   AllowTimer := True;
  92. {$IFDEF WIN32}
  93.   ControlStyle := ControlStyle + [csReplicatable];
  94. {$ENDIF}
  95. end;
  96.  
  97. { TRxCalendar }
  98.  
  99. { TRxCalendar implementation copied from Borland CALENDAR.PAS sample unit
  100.   and modified }
  101.  
  102. type
  103.   TDayOfWeek = 0..6;
  104.  
  105.   TRxCalendar = class(TCustomGrid)
  106.   private
  107.     FDate: TDateTime;
  108.     FMonthOffset: Integer;
  109.     FOnChange: TNotifyEvent;
  110.     FReadOnly: Boolean;
  111.     FStartOfWeek: TDayOfWeekName;
  112.     FUpdating: Boolean;
  113.     FUseCurrentDate: Boolean;
  114.     FWeekends: TDaysOfWeek;
  115.     FWeekendColor: TColor;
  116.     function GetCellText(ACol, ARow: Integer): string;
  117.     function GetDateElement(Index: Integer): Integer;
  118.     procedure SetCalendarDate(Value: TDateTime);
  119.     procedure SetDateElement(Index: Integer; Value: Integer);
  120.     procedure SetStartOfWeek(Value: TDayOfWeekName);
  121.     procedure SetUseCurrentDate(Value: Boolean);
  122.     procedure SetWeekendColor(Value: TColor);
  123.     procedure SetWeekends(Value: TDaysOfWeek);
  124.     function IsWeekend(ACol, ARow: Integer): Boolean;
  125.     procedure CalendarUpdate(DayOnly: Boolean);
  126.     function StoreCalendarDate: Boolean;
  127.   protected
  128.     procedure CreateParams(var Params: TCreateParams); override;
  129.     procedure Change; dynamic;
  130.     procedure ChangeMonth(Delta: Integer);
  131.     procedure Click; override;
  132.     function DaysThisMonth: Integer;
  133.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  134.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  135.     procedure KeyPress(var Key: Char); override;
  136.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  137.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  138.   public
  139.     constructor Create(AOwner: TComponent); override;
  140.     procedure NextMonth;
  141.     procedure NextYear;
  142.     procedure PrevMonth;
  143.     procedure PrevYear;
  144.     procedure UpdateCalendar; virtual;
  145.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  146.   published
  147.     property CalendarDate: TDateTime read FDate write SetCalendarDate
  148.       stored StoreCalendarDate;
  149.     property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
  150.     property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
  151.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  152.     property StartOfWeek: TDayOfWeekName read FStartOfWeek write SetStartOfWeek default Mon;
  153.     property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
  154.     property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clRed;
  155.     property Weekends: TDaysOfWeek read FWeekends write SetWeekends default [Sun];
  156.     property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
  157.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  158.   end;
  159.  
  160. constructor TRxCalendar.Create(AOwner: TComponent);
  161. begin
  162.   inherited Create(AOwner);
  163.   FUseCurrentDate := True;
  164.   FStartOfWeek := Mon;
  165.   FWeekends := [Sun];
  166.   FWeekendColor := clRed;
  167.   FixedCols := 0;
  168.   FixedRows := 1;
  169.   ColCount := 7;
  170.   RowCount := 7;
  171.   ScrollBars := ssNone;
  172.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  173.   ControlStyle := ControlStyle + [csFramed];
  174.   FDate := Date;
  175.   UpdateCalendar;
  176. end;
  177.  
  178. procedure TRxCalendar.CreateParams(var Params: TCreateParams);
  179. begin
  180.   inherited CreateParams(Params);
  181.   Params.Style := Params.Style or WS_BORDER;
  182. {$IFDEF WIN32}
  183.   Params.ExStyle := Params.ExStyle and not WS_EX_CLIENTEDGE;
  184. {$ENDIF}
  185. {$IFDEF RX_D4}
  186.   AddBiDiModeExStyle(Params.ExStyle);
  187. {$ENDIF}
  188. end;
  189.  
  190. procedure TRxCalendar.Change;
  191. begin
  192.   if Assigned(FOnChange) then FOnChange(Self);
  193. end;
  194.  
  195. procedure TRxCalendar.Click;
  196. var
  197.   TheCellText: string;
  198. begin
  199.   inherited Click;
  200.   TheCellText := CellText[Col, Row];
  201.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  202. end;
  203.  
  204. function TRxCalendar.DaysThisMonth: Integer;
  205. begin
  206.   Result := DaysPerMonth(Year, Month);
  207. end;
  208.  
  209. procedure TRxCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  210. var
  211.   TheText: string;
  212. begin
  213.   TheText := CellText[ACol, ARow];
  214.   with ARect, Canvas do begin
  215.     if IsWeekend(ACol, ARow) and not (gdSelected in AState) then
  216.       Font.Color := WeekendColor;
  217.     TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
  218.       Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  219.   end;
  220. end;
  221.  
  222. function TRxCalendar.GetCellText(ACol, ARow: Integer): string;
  223. var
  224.   DayNum: Integer;
  225. begin
  226.   if ARow = 0 then  { day names at tops of columns }
  227.     Result := ShortDayNames[(Ord(StartOfWeek) + ACol) mod 7 + 1]
  228.   else begin
  229.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  230.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  231.     else Result := IntToStr(DayNum);
  232.   end;
  233. end;
  234.  
  235. procedure TRxCalendar.KeyDown(var Key: Word; Shift: TShiftState);
  236. begin
  237.   if Shift = [] then
  238.     case Key of
  239.       VK_LEFT, VK_SUBTRACT:
  240.         begin
  241.           if (Day > 1) then Day := Day - 1
  242.           else CalendarDate := CalendarDate - 1;
  243.           Exit;
  244.         end;
  245.       VK_RIGHT, VK_ADD:
  246.         begin
  247.           if (Day < DaysThisMonth) then Day := Day + 1
  248.           else CalendarDate := CalendarDate + 1;
  249.           Exit;
  250.         end
  251.     end;
  252.   inherited KeyDown(Key, Shift);
  253. end;
  254.  
  255. procedure TRxCalendar.KeyPress(var Key: Char);
  256. begin
  257.   if Key in ['T', 't'] then begin
  258.     CalendarDate := Trunc(Now);
  259.     Key := #0;
  260.   end;
  261.   inherited KeyPress(Key);
  262. end;
  263.  
  264. function TRxCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  265. begin
  266.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  267.     Result := False
  268.   else Result := inherited SelectCell(ACol, ARow);
  269. end;
  270.  
  271. procedure TRxCalendar.SetCalendarDate(Value: TDateTime);
  272. begin
  273.   if FDate <> Value then begin
  274.     FDate := Value;
  275.     UpdateCalendar;
  276.     Change;
  277.   end;
  278. end;
  279.  
  280. function TRxCalendar.StoreCalendarDate: Boolean;
  281. begin
  282.   Result := not FUseCurrentDate;
  283. end;
  284.  
  285. function TRxCalendar.GetDateElement(Index: Integer): Integer;
  286. var
  287.   AYear, AMonth, ADay: Word;
  288. begin
  289.   DecodeDate(FDate, AYear, AMonth, ADay);
  290.   case Index of
  291.     1: Result := AYear;
  292.     2: Result := AMonth;
  293.     3: Result := ADay;
  294.     else Result := -1;
  295.   end;
  296. end;
  297.  
  298. procedure TRxCalendar.SetDateElement(Index: Integer; Value: Integer);
  299. var
  300.   AYear, AMonth, ADay: Word;
  301. begin
  302.   if Value > 0 then begin
  303.     DecodeDate(FDate, AYear, AMonth, ADay);
  304.     case Index of
  305.       1: if AYear <> Value then AYear := Value else Exit;
  306.       2: if (Value <= 12) and (Value <> AMonth) then begin
  307.            AMonth := Value;
  308.            if ADay > DaysPerMonth(Year, Value) then
  309.              ADay := DaysPerMonth(Year, Value);
  310.          end else Exit;
  311.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then
  312.            ADay := Value
  313.          else Exit;
  314.       else Exit;
  315.     end;
  316.     FDate := EncodeDate(AYear, AMonth, ADay);
  317.     FUseCurrentDate := False;
  318.     CalendarUpdate(Index = 3);
  319.     Change;
  320.   end;
  321. end;
  322.  
  323. procedure TRxCalendar.SetWeekendColor(Value: TColor);
  324. begin
  325.   if Value <> FWeekendColor then begin
  326.     FWeekendColor := Value;
  327.     Invalidate;
  328.   end;
  329. end;
  330.  
  331. procedure TRxCalendar.SetWeekends(Value: TDaysOfWeek);
  332. begin
  333.   if Value <> FWeekends then begin
  334.     FWeekends := Value;
  335.     UpdateCalendar;
  336.   end;
  337. end;
  338.  
  339. function TRxCalendar.IsWeekend(ACol, ARow: Integer): Boolean;
  340. begin
  341.   Result := TDayOfWeekName((Integer(StartOfWeek) + ACol) mod 7) in FWeekends;
  342. end;
  343.  
  344. procedure TRxCalendar.SetStartOfWeek(Value: TDayOfWeekName);
  345. begin
  346.   if Value <> FStartOfWeek then begin
  347.     FStartOfWeek := Value;
  348.     UpdateCalendar;
  349.   end;
  350. end;
  351.  
  352. procedure TRxCalendar.SetUseCurrentDate(Value: Boolean);
  353. begin
  354.   if Value <> FUseCurrentDate then begin
  355.     FUseCurrentDate := Value;
  356.     if Value then begin
  357.       FDate := Date; { use the current date, then }
  358.       UpdateCalendar;
  359.     end;
  360.   end;
  361. end;
  362.  
  363. { Given a value of 1 or -1, moves to Next or Prev month accordingly }
  364. procedure TRxCalendar.ChangeMonth(Delta: Integer);
  365. var
  366.   AYear, AMonth, ADay: Word;
  367.   NewDate: TDateTime;
  368.   CurDay: Integer;
  369. begin
  370.   DecodeDate(FDate, AYear, AMonth, ADay);
  371.   CurDay := ADay;
  372.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  373.   else ADay := 1;
  374.   NewDate := EncodeDate(AYear, AMonth, ADay);
  375.   NewDate := NewDate + Delta;
  376.   DecodeDate(NewDate, AYear, AMonth, ADay);
  377.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  378.   else ADay := DaysPerMonth(AYear, AMonth);
  379.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  380. end;
  381.  
  382. procedure TRxCalendar.PrevMonth;
  383. begin
  384.   ChangeMonth(-1);
  385. end;
  386.  
  387. procedure TRxCalendar.NextMonth;
  388. begin
  389.   ChangeMonth(1);
  390. end;
  391.  
  392. procedure TRxCalendar.NextYear;
  393. begin
  394.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  395.   Year := Year + 1;
  396. end;
  397.  
  398. procedure TRxCalendar.PrevYear;
  399. begin
  400.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  401.   Year := Year - 1;
  402. end;
  403.  
  404. procedure TRxCalendar.CalendarUpdate(DayOnly: Boolean);
  405. var
  406.   AYear, AMonth, ADay: Word;
  407.   FirstDate: TDateTime;
  408. begin
  409.   FUpdating := True;
  410.   try
  411.     DecodeDate(FDate, AYear, AMonth, ADay);
  412.     FirstDate := EncodeDate(AYear, AMonth, 1);
  413.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - Ord(StartOfWeek) + 7) mod 7);
  414.       { day of week for 1st of month }
  415.     if FMonthOffset = 2 then FMonthOffset := -5;
  416.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  417.       False, False);
  418.     if DayOnly then Update else Invalidate;
  419.   finally
  420.     FUpdating := False;
  421.   end;
  422. end;
  423.  
  424. procedure TRxCalendar.UpdateCalendar;
  425. begin
  426.   CalendarUpdate(False);
  427. end;
  428.  
  429. procedure TRxCalendar.WMSize(var Message: TWMSize);
  430. var
  431.   GridLinesH, GridLinesW: Integer;
  432. begin
  433.   GridLinesH := 6 * GridLineWidth;
  434.   if (goVertLine in Options) or (goFixedVertLine in Options) then
  435.     GridLinesW := 6 * GridLineWidth
  436.   else GridLinesW := 0;
  437.   DefaultColWidth := (Message.Width - GridLinesW) div 7;
  438.   DefaultRowHeight := (Message.Height - GridLinesH) div 7;
  439. end;
  440.  
  441. { TLocCalendar }
  442.  
  443. type
  444.   TLocCalendar = class(TRxCalendar)
  445.   private
  446.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  447.     procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
  448.   protected
  449.     procedure CreateParams(var Params: TCreateParams); override;
  450.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  451.   public
  452.     constructor Create(AOwner: TComponent); override;
  453.     procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  454.     property GridLineWidth;
  455.     property DefaultColWidth;
  456.     property DefaultRowHeight;
  457.   end;
  458.  
  459. constructor TLocCalendar.Create(AOwner: TComponent);
  460. begin
  461.   inherited Create(AOwner);
  462.   ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];
  463. {$IFDEF WIN32}
  464.   ControlStyle := ControlStyle + [csReplicatable];
  465. {$ENDIF}
  466.   Ctl3D := False;
  467.   Enabled := False;
  468.   BorderStyle := bsNone;
  469.   ParentColor := True;
  470.   CalendarDate := Trunc(Now);
  471.   UseCurrentDate := False;
  472.   FixedColor := Self.Color;
  473.   Options := [goFixedHorzLine];
  474.   TabStop := False;
  475. end;
  476.  
  477. procedure TLocCalendar.CMParentColorChanged(var Message: TMessage);
  478. begin
  479.   inherited;
  480.   if ParentColor then FixedColor := Self.Color;
  481. end;
  482.  
  483. procedure TLocCalendar.CMEnabledChanged(var Message: TMessage);
  484. begin
  485.   if HandleAllocated and not (csDesigning in ComponentState) then
  486.     EnableWindow(Handle, True);
  487. end;
  488.  
  489. procedure TLocCalendar.CreateParams(var Params: TCreateParams);
  490. begin
  491.   inherited CreateParams(Params);
  492.   with Params do
  493.     Style := Style and not (WS_BORDER or WS_TABSTOP or WS_DISABLED);
  494. end;
  495.  
  496. procedure TLocCalendar.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  497. var
  498.   Coord: TGridCoord;
  499. begin
  500.   Coord := MouseCoord(X, Y);
  501.   ACol := Coord.X;
  502.   ARow := Coord.Y;
  503. end;
  504.  
  505. procedure TLocCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect;
  506.   AState: TGridDrawState);
  507. var
  508.   D, M, Y: Word;
  509. begin
  510.   inherited DrawCell(ACol, ARow, ARect, AState);
  511.   DecodeDate(CalendarDate, Y, M, D);
  512.   D := StrToIntDef(CellText[ACol, ARow], 0);
  513.   if (D > 0) and (D <= DaysPerMonth(Y, M)) then begin
  514.     if (EncodeDate(Y, M, D) = SysUtils.Date) then
  515.       Frame3D(Canvas, ARect, clBtnShadow, clBtnHighlight, 1);
  516.   end;
  517. end;
  518.  
  519. { TPopupCalendar }
  520.  
  521. type
  522.   TPopupCalendar = class(TPopupWindow)
  523.   private
  524.     FCalendar: TRxCalendar;
  525.     FTitleLabel: TLabel;
  526.     FFourDigitYear: Boolean;
  527.     FBtns: array[0..3] of TRxSpeedButton;
  528.     procedure CalendarMouseUp(Sender: TObject; Button: TMouseButton;
  529.       Shift: TShiftState; X, Y: Integer);
  530.     procedure PrevMonthBtnClick(Sender: TObject);
  531.     procedure NextMonthBtnClick(Sender: TObject);
  532.     procedure PrevYearBtnClick(Sender: TObject);
  533.     procedure NextYearBtnClick(Sender: TObject);
  534.     procedure CalendarChange(Sender: TObject);
  535.     procedure TopPanelDblClick(Sender: TObject);
  536.   protected
  537.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  538.     procedure KeyPress(var Key: Char); override;
  539. {$IFDEF WIN32}
  540.     function GetValue: Variant; override;
  541.     procedure SetValue(const Value: Variant); override;
  542. {$ELSE}
  543.     function GetValue: string; override;
  544.     procedure SetValue(const Value: string); override;
  545. {$ENDIF}
  546.   public
  547.     constructor Create(AOwner: TComponent); override;
  548.   end;
  549.  
  550. function CreatePopupCalendar(AOwner: TComponent
  551.   {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
  552. begin
  553.   Result := TPopupCalendar.Create(AOwner);
  554.   if (AOwner <> nil) and not (csDesigning in AOwner.ComponentState) and
  555.     (Screen.PixelsPerInch <> 96) then
  556.   begin { scale to screen res }
  557.     Result.ScaleBy(Screen.PixelsPerInch, 96);
  558.     { The ScaleBy method does not scale the font well, so set the
  559.       font back to the original info. }
  560.     TPopupCalendar(Result).FCalendar.ParentFont := True;
  561.     FontSetDefault(TPopupCalendar(Result).Font);
  562. {$IFDEF RX_D4}
  563.     Result.BiDiMode := ABiDiMode;
  564. {$ENDIF}
  565.   end;
  566. end;
  567.  
  568. procedure SetupPopupCalendar(PopupCalendar: TWinControl;
  569.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  570.   AWeekendColor: TColor; BtnHints: TStrings; FourDigitYear: Boolean);
  571. var
  572.   I: Integer;
  573. begin
  574.   if (PopupCalendar = nil) or not (PopupCalendar is TPopupCalendar) then
  575.     Exit;
  576.   TPopupCalendar(PopupCalendar).FFourDigitYear := FourDigitYear;
  577.   if TPopupCalendar(PopupCalendar).FCalendar <> nil then begin
  578.     with TPopupCalendar(PopupCalendar).FCalendar do begin
  579.       StartOfWeek := AStartOfWeek;
  580.       WeekendColor := AWeekendColor;
  581.       Weekends := AWeekends;
  582.     end;
  583.     if (BtnHints <> nil) then
  584.       for I := 0 to Min(BtnHints.Count - 1, 3) do begin
  585.         if BtnHints[I] <> '' then
  586.           TPopupCalendar(PopupCalendar).FBtns[I].Hint := BtnHints[I];
  587.       end;
  588.   end;
  589. end;
  590.  
  591. constructor TPopupCalendar.Create(AOwner: TComponent);
  592. const
  593.   BtnSide = 14;
  594. var
  595.   Control, BackPanel: TWinControl;
  596. begin
  597.   inherited Create(AOwner);
  598.   FFourDigitYear := FourDigitYear;
  599.   Height := Max(PopupCalendarSize.Y, 120);
  600.   Width := Max(PopupCalendarSize.X, 180);
  601.   Color := clBtnFace;
  602.   FontSetDefault(Font);
  603.   if AOwner is TControl then ShowHint := TControl(AOwner).ShowHint
  604.   else ShowHint := True;
  605.   if (csDesigning in ComponentState) then Exit;
  606.  
  607.   BackPanel := TPanel.Create(Self);
  608.   with BackPanel as TPanel do begin
  609.     Parent := Self;
  610.     Align := alClient;
  611.     ParentColor := True;
  612. {$IFDEF WIN32}
  613.     ControlStyle := ControlStyle + [csReplicatable];
  614. {$ENDIF}
  615.   end;
  616.  
  617.   Control := TPanel.Create(Self);
  618.   with Control as TPanel do begin
  619.     Parent := BackPanel;
  620.     Align := alTop;
  621.     Width := Self.Width - 4;
  622.     Height := 18;
  623.     BevelOuter := bvNone;
  624.     ParentColor := True;
  625. {$IFDEF WIN32}
  626.     ControlStyle := ControlStyle + [csReplicatable];
  627. {$ENDIF}
  628.   end;
  629.  
  630.   FCalendar := TLocCalendar.Create(Self);
  631.   with TLocCalendar(FCalendar) do begin
  632.     Parent := BackPanel;
  633.     Align := alClient;
  634.     OnChange := CalendarChange;
  635.     OnMouseUp := CalendarMouseUp;
  636.   end;
  637.  
  638.   FBtns[0] := TRxTimerSpeedButton.Create(Self);
  639.   with FBtns[0] do begin
  640.     Parent := Control;
  641.     SetBounds(-1, -1, BtnSide, BtnSide);
  642.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[0]);
  643.     OnClick := PrevYearBtnClick;
  644.     Hint := LoadStr(SPrevYear);
  645.   end;
  646.  
  647.   FBtns[1] := TRxTimerSpeedButton.Create(Self);
  648.   with FBtns[1] do begin
  649.     Parent := Control;
  650.     SetBounds(BtnSide - 2, -1, BtnSide, BtnSide);
  651.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[1]);
  652.     OnClick := PrevMonthBtnClick;
  653.     Hint := LoadStr(SPrevMonth);
  654.   end;
  655.  
  656.   FTitleLabel := TLabel.Create(Self);
  657.   with FTitleLabel do begin
  658.     Parent := Control;
  659.     AutoSize := False;
  660.     Alignment := taCenter;
  661.     SetBounds(BtnSide * 2 + 1, 1, Control.Width - 4 * BtnSide - 2, 14);
  662.     Transparent := True;
  663.     OnDblClick := TopPanelDblClick;
  664. {$IFDEF WIN32}
  665.     ControlStyle := ControlStyle + [csReplicatable];
  666. {$ENDIF}
  667.   end;
  668.  
  669.   FBtns[2] := TRxTimerSpeedButton.Create(Self);
  670.   with FBtns[2] do begin
  671.     Parent := Control;
  672.     SetBounds(Control.Width - 2 * BtnSide + 2, -1, BtnSide, BtnSide);
  673.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[2]);
  674.     OnClick := NextMonthBtnClick;
  675.     Hint := LoadStr(SNextMonth);
  676.   end;
  677.  
  678.   FBtns[3] := TRxTimerSpeedButton.Create(Self);
  679.   with FBtns[3] do begin
  680.     Parent := Control;
  681.     SetBounds(Control.Width - BtnSide + 1, -1, BtnSide, BtnSide);
  682.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[3]);
  683.     OnClick := NextYearBtnClick;
  684.     Hint := LoadStr(SNextYear);
  685.   end;
  686. end;
  687.  
  688. procedure TPopupCalendar.CalendarMouseUp(Sender: TObject; Button: TMouseButton;
  689.   Shift: TShiftState; X, Y: Integer);
  690. var
  691.   Col, Row: Longint;
  692. begin
  693.   if (Button = mbLeft) and (Shift = []) then begin
  694.     TLocCalendar(FCalendar).MouseToCell(X, Y, Col, Row);
  695.     if (Row > 0) and (FCalendar.CellText[Col, Row] <> '') then
  696.       CloseUp(True);
  697.   end;
  698. end;
  699.  
  700. procedure TPopupCalendar.TopPanelDblClick(Sender: TObject);
  701. begin
  702.   FCalendar.CalendarDate := Trunc(Now);
  703. end;
  704.  
  705. procedure TPopupCalendar.KeyDown(var Key: Word; Shift: TShiftState);
  706. begin
  707.   inherited KeyDown(Key, Shift);
  708.   if FCalendar <> nil then
  709.     case Key of
  710.       VK_NEXT:
  711.         begin
  712.           if ssCtrl in Shift then FCalendar.NextYear
  713.           else FCalendar.NextMonth;
  714.         end;
  715.       VK_PRIOR:
  716.         begin
  717.           if ssCtrl in Shift then FCalendar.PrevYear
  718.           else FCalendar.PrevMonth;
  719.         end;
  720.       else TLocCalendar(FCalendar).KeyDown(Key, Shift);
  721.     end;
  722. end;
  723.  
  724. procedure TPopupCalendar.KeyPress(var Key: Char);
  725. begin
  726.   inherited KeyPress(Key);
  727.   if (FCalendar <> nil) and (Key <> #0) then
  728.     FCalendar.KeyPress(Key);
  729. end;
  730.  
  731. {$IFDEF WIN32}
  732.  
  733. function TPopupCalendar.GetValue: Variant;
  734. begin
  735.   if (csDesigning in ComponentState) then
  736.     Result := VarFromDateTime(SysUtils.Date)
  737.   else
  738.     Result := VarFromDateTime(FCalendar.CalendarDate);
  739. end;
  740.  
  741. procedure TPopupCalendar.SetValue(const Value: Variant);
  742. begin
  743.   if not (csDesigning in ComponentState) then begin
  744.     try
  745.       if (Trim(ReplaceStr(VarToStr(Value), DateSeparator, '')) = '') or
  746.         VarIsNull(Value) or VarIsEmpty(Value) then
  747.         FCalendar.CalendarDate := VarToDateTime(SysUtils.Date)
  748.       else FCalendar.CalendarDate := VarToDateTime(Value);
  749.       CalendarChange(nil);
  750.     except
  751.       FCalendar.CalendarDate := VarToDateTime(SysUtils.Date);
  752.     end;
  753.   end;
  754. end;
  755.  
  756. {$ELSE}
  757.  
  758. function TPopupCalendar.GetValue: string;
  759. begin
  760.   if (csDesigning in ComponentState) then
  761.     Result := FormatDateTime(DefDateFormat(FFourDigitYear), SysUtils.Date)
  762.   else
  763.     Result := FormatDateTime(DefDateFormat(FFourDigitYear), FCalendar.CalendarDate);
  764. end;
  765.  
  766. procedure TPopupCalendar.SetValue(const Value: string);
  767. begin
  768.   if not (csDesigning in ComponentState) then begin
  769.     FCalendar.CalendarDate := StrToDateFmtDef(DefDateFormat(FFourDigitYear),
  770.       Value, SysUtils.Date);
  771.     CalendarChange(nil);
  772.   end;
  773. end;
  774.  
  775. {$ENDIF}
  776.  
  777. procedure TPopupCalendar.PrevYearBtnClick(Sender: TObject);
  778. begin
  779.   FCalendar.PrevYear;
  780. end;
  781.  
  782. procedure TPopupCalendar.NextYearBtnClick(Sender: TObject);
  783. begin
  784.   FCalendar.NextYear;
  785. end;
  786.  
  787. procedure TPopupCalendar.PrevMonthBtnClick(Sender: TObject);
  788. begin
  789.   FCalendar.PrevMonth;
  790. end;
  791.  
  792. procedure TPopupCalendar.NextMonthBtnClick(Sender: TObject);
  793. begin
  794.   FCalendar.NextMonth;
  795. end;
  796.  
  797. procedure TPopupCalendar.CalendarChange(Sender: TObject);
  798. begin
  799.   FTitleLabel.Caption := FormatDateTime('MMMM, YYYY', FCalendar.CalendarDate);
  800. end;
  801.  
  802. { TSelectDateDlg }
  803.  
  804. type
  805.   TSelectDateDlg = class(TForm)
  806.     Calendar: TRxCalendar;
  807.     TitleLabel: TLabel;
  808.     procedure PrevMonthBtnClick(Sender: TObject);
  809.     procedure NextMonthBtnClick(Sender: TObject);
  810.     procedure PrevYearBtnClick(Sender: TObject);
  811.     procedure NextYearBtnClick(Sender: TObject);
  812.     procedure CalendarChange(Sender: TObject);
  813.     procedure CalendarDblClick(Sender: TObject);
  814.     procedure TopPanelDblClick(Sender: TObject);
  815.     procedure FormKeyDown(Sender: TObject; var Key: Word;
  816.       Shift: TShiftState);
  817.   private
  818.     { Private declarations }
  819.     FBtns: array[0..3] of TRxSpeedButton;
  820.     procedure SetDate(Date: TDateTime);
  821.     function GetDate: TDateTime;
  822.   public
  823.     { Public declarations }
  824.     constructor Create(AOwner: TComponent); override;
  825.     property Date: TDateTime read GetDate write SetDate;
  826.   end;
  827.  
  828. constructor TSelectDateDlg.Create(AOwner: TComponent);
  829. var
  830.   Control: TWinControl;
  831. begin
  832. {$IFDEF CBUILDER}
  833.   inherited CreateNew(AOwner, 0);
  834. {$ELSE}
  835.   inherited CreateNew(AOwner);
  836. {$ENDIF}
  837.   Caption := LoadStr(SDateDlgTitle);
  838. {$IFDEF WIN32}
  839.   BorderStyle := bsToolWindow;
  840. {$ELSE}
  841.   BorderStyle := bsDialog;
  842. {$ENDIF}
  843.   BorderIcons := [biSystemMenu];
  844.   ClientHeight := 154;
  845.   ClientWidth := 222;
  846.   FontSetDefault(Font);
  847.   Color := clBtnFace;
  848.   Position := poScreenCenter;
  849.   ShowHint := True;
  850.   KeyPreview := True;
  851.  
  852.   Control := TPanel.Create(Self);
  853.   with Control as TPanel do begin
  854.     Parent := Self;
  855.     SetBounds(0, 0, 222, 22);
  856.     Align := alTop;
  857.     BevelInner := bvLowered;
  858.     ParentColor := True;
  859.     ParentFont := True;
  860.   end;
  861.  
  862.   TitleLabel := TLabel.Create(Self);
  863.   with TitleLabel do begin
  864.     Parent := Control;
  865.     SetBounds(35, 4, 152, 14);
  866.     Alignment := taCenter;
  867.     AutoSize := False;
  868.     Caption := '';
  869.     ParentFont := True;
  870.     Font.Color := clBlue;
  871.     Font.Style := [fsBold];
  872.     Transparent := True;
  873.     OnDblClick := TopPanelDblClick;
  874.   end;
  875.  
  876.   FBtns[0] := TRxTimerSpeedButton.Create(Self);
  877.   with FBtns[0] do begin
  878.     Parent := Control;
  879.     SetBounds(3, 3, 16, 16);
  880.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[0]);
  881.     OnClick := PrevYearBtnClick;
  882.     Hint := LoadStr(SPrevYear);
  883.   end;
  884.  
  885.   FBtns[1] := TRxTimerSpeedButton.Create(Self);
  886.   with FBtns[1] do begin
  887.     Parent := Control;
  888.     SetBounds(18, 3, 16, 16);
  889.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[1]);
  890.     OnClick := PrevMonthBtnClick;
  891.     Hint := LoadStr(SPrevMonth);
  892.   end;
  893.  
  894.   FBtns[2] := TRxTimerSpeedButton.Create(Self);
  895.   with FBtns[2] do begin
  896.     Parent := Control;
  897.     SetBounds(188, 3, 16, 16);
  898.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[2]);
  899.     OnClick := NextMonthBtnClick;
  900.     Hint := LoadStr(SNextMonth);
  901.   end;
  902.  
  903.   FBtns[3] := TRxTimerSpeedButton.Create(Self);
  904.   with FBtns[3] do begin
  905.     Parent := Control;
  906.     SetBounds(203, 3, 16, 16);
  907.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[3]);
  908.     OnClick := NextYearBtnClick;
  909.     Hint := LoadStr(SNextYear);
  910.   end;
  911.  
  912.   Control := TPanel.Create(Self);
  913.   with Control as TPanel do begin
  914.     Parent := Self;
  915.     SetBounds(0, 133, 222, 21);
  916.     Align := alBottom;
  917.     BevelInner := bvNone;
  918.     BevelOuter := bvNone;
  919.     ParentFont := True;
  920.     ParentColor := True;
  921.   end;
  922.  
  923.   with TButton.Create(Self) do begin
  924.     Parent := Control;
  925.     SetBounds(0, 0, 112, 21);
  926.     Caption := ResStr(SOKButton);
  927.     ModalResult := mrOk;
  928.   end;
  929.  
  930.   with TButton.Create(Self) do begin
  931.     Parent := Control;
  932.     SetBounds(111, 0, 111, 21);
  933.     Caption := ResStr(SCancelButton);
  934.     ModalResult := mrCancel;
  935.     Cancel := True;
  936.   end;
  937.  
  938.   Control := TPanel.Create(Self);
  939.   with Control as TPanel do begin
  940.     Parent := Self;
  941.     SetBounds(0, 22, 222, 111);
  942.     Align := alClient;
  943.     BevelInner := bvLowered;
  944.     ParentFont := True;
  945.     ParentColor := True;
  946.   end;
  947.  
  948.   Calendar := TRxCalendar.Create(Self);
  949.   with Calendar do begin
  950.     Parent := Control;
  951.     Align := alClient;
  952.     ParentFont := True;
  953.     SetBounds(2, 2, 218, 113);
  954.     Color := clWhite;
  955.     TabOrder := 0;
  956.     UseCurrentDate := False;
  957.     OnChange := CalendarChange;
  958.     OnDblClick := CalendarDblClick;
  959.   end;
  960.  
  961.   OnKeyDown := FormKeyDown;
  962.   Calendar.CalendarDate := Trunc(Now);
  963.   ActiveControl := Calendar;
  964. end;
  965.  
  966. procedure TSelectDateDlg.SetDate(Date: TDateTime);
  967. begin
  968.   if Date = NullDate then Date := SysUtils.Date;
  969.   try
  970.     Calendar.CalendarDate := Date;
  971.     CalendarChange(nil);
  972.   except
  973.     Calendar.CalendarDate := SysUtils.Date;
  974.   end;
  975. end;
  976.  
  977. function TSelectDateDlg.GetDate: TDateTime;
  978. begin
  979.   Result := Calendar.CalendarDate;
  980. end;
  981.  
  982. procedure TSelectDateDlg.TopPanelDblClick(Sender: TObject);
  983. begin
  984.   SetDate(Trunc(Now));
  985. end;
  986.  
  987. procedure TSelectDateDlg.PrevYearBtnClick(Sender: TObject);
  988. begin
  989.   Calendar.PrevYear;
  990. end;
  991.  
  992. procedure TSelectDateDlg.NextYearBtnClick(Sender: TObject);
  993. begin
  994.   Calendar.NextYear;
  995. end;
  996.  
  997. procedure TSelectDateDlg.PrevMonthBtnClick(Sender: TObject);
  998. begin
  999.   Calendar.PrevMonth;
  1000. end;
  1001.  
  1002. procedure TSelectDateDlg.NextMonthBtnClick(Sender: TObject);
  1003. begin
  1004.   Calendar.NextMonth;
  1005. end;
  1006.  
  1007. procedure TSelectDateDlg.CalendarChange(Sender: TObject);
  1008. begin
  1009.   TitleLabel.Caption := FormatDateTime('MMMM, YYYY', Calendar.CalendarDate);
  1010. end;
  1011.  
  1012. procedure TSelectDateDlg.CalendarDblClick(Sender: TObject);
  1013. begin
  1014.   ModalResult := mrOK;
  1015. end;
  1016.  
  1017. procedure TSelectDateDlg.FormKeyDown(Sender: TObject; var Key: Word;
  1018.   Shift: TShiftState);
  1019. begin
  1020.   case Key of
  1021.     VK_RETURN: ModalResult := mrOK;
  1022.     VK_ESCAPE: ModalResult := mrCancel;
  1023.     VK_NEXT:
  1024.       begin
  1025.         if ssCtrl in Shift then Calendar.NextYear
  1026.         else Calendar.NextMonth;
  1027.         TitleLabel.Update;
  1028.       end;
  1029.     VK_PRIOR:
  1030.       begin
  1031.         if ssCtrl in Shift then Calendar.PrevYear
  1032.         else Calendar.PrevMonth;
  1033.         TitleLabel.Update;
  1034.       end;
  1035.     VK_TAB:
  1036.       begin
  1037.         if Shift = [ssShift] then Calendar.PrevMonth
  1038.         else Calendar.NextMonth;
  1039.         TitleLabel.Update;
  1040.       end;
  1041.   end; {case}
  1042. end;
  1043.  
  1044. { SelectDate routines }
  1045.  
  1046. function CreateDateDialog(const DlgCaption: TCaption): TSelectDateDlg;
  1047. begin
  1048.   Result := TSelectDateDlg.Create(Application);
  1049.   try
  1050.     if DlgCaption <> '' then Result.Caption := DlgCaption;
  1051.     if Screen.PixelsPerInch <> 96 then begin { scale to screen res }
  1052.       Result.ScaleBy(Screen.PixelsPerInch, 96);
  1053.       { The ScaleBy method does not scale the font well, so set the
  1054.         font back to the original info. }
  1055.       Result.Calendar.ParentFont := True;
  1056.       FontSetDefault(Result.Font);
  1057.       Result.Left := (Screen.Width div 2) - (Result.Width div 2);
  1058.       Result.Top := (Screen.Height div 2) - (Result.Height div 2);
  1059.     end;
  1060.   except
  1061.     Result.Free;
  1062.     raise;
  1063.   end;
  1064. end;
  1065.  
  1066. function PopupDate(var Date: TDateTime; Edit: TWinControl): Boolean;
  1067. var
  1068.   D: TSelectDateDlg;
  1069.   P: TPoint;
  1070.   W, H, X, Y: Integer;
  1071. begin
  1072.   Result := False;
  1073.   D := CreateDateDialog('');
  1074.   try
  1075.     D.BorderIcons := [];
  1076.     D.HandleNeeded;
  1077.     D.Position := poDesigned;
  1078.     W := D.Width;
  1079.     H := D.Height;
  1080.     P := (Edit.ClientOrigin);
  1081.     Y := P.Y + Edit.Height - 1;
  1082.     if (Y + H) > Screen.Height then Y := P.Y - H + 1;
  1083.     if Y < 0 then Y := P.Y + Edit.Height - 1;
  1084.     X := (P.X + Edit.Width) - W;
  1085.     if X < 0 then X := P.X;
  1086.     D.Left := X;
  1087.     D.Top := Y;
  1088.     D.Date := Date;
  1089.     if D.ShowModal = mrOk then begin
  1090.       Date := D.Date;
  1091.       Result := True;
  1092.     end;
  1093.   finally
  1094.     D.Free;
  1095.   end;
  1096. end;
  1097.  
  1098. function SelectDate(var Date: TDateTime; const DlgCaption: TCaption;
  1099.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  1100.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  1101. var
  1102.   D: TSelectDateDlg;
  1103.   I: Integer;
  1104. begin
  1105.   Result := False;
  1106.   D := CreateDateDialog(DlgCaption);
  1107.   try
  1108.     D.Date := Date;
  1109.     with D.Calendar do begin
  1110.       StartOfWeek := AStartOfWeek;
  1111.       Weekends := AWeekends;
  1112.       WeekendColor := AWeekendColor;
  1113.     end;
  1114.     if (BtnHints <> nil) then
  1115.       for I := 0 to Min(BtnHints.Count - 1, 3) do begin
  1116.         if BtnHints[I] <> '' then
  1117.           D.FBtns[I].Hint := BtnHints[I];
  1118.       end;
  1119.     if D.ShowModal = mrOk then begin
  1120.       Date := D.Date;
  1121.       Result := True;
  1122.     end;
  1123.   finally
  1124.     D.Free;
  1125.   end;
  1126. end;
  1127.  
  1128. function SelectDateStr(var StrDate: string; const DlgCaption: TCaption;
  1129.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  1130.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  1131. var
  1132.   DateValue: TDateTime;
  1133. begin
  1134.   if StrDate <> '' then begin
  1135.     try
  1136.       DateValue := StrToDateFmt(ShortDateFormat, StrDate);
  1137.     except
  1138.       DateValue := Date;
  1139.     end;
  1140.   end
  1141.   else DateValue := Date;
  1142.   Result := SelectDate(DateValue, DlgCaption, AStartOfWeek, AWeekends,
  1143.     AWeekendColor, BtnHints);
  1144.   if Result then StrDate := FormatDateTime(ShortDateFormat, DateValue);
  1145. end;
  1146.  
  1147. end.
  1148.